home *** CD-ROM | disk | FTP | other *** search
/ SPACE 2 / SPACE - Library 2 - Volume 1.iso / apps / 6 / applic / bioryt.bas < prev    next >
Encoding:
BASIC Source File  |  1985-11-19  |  3.5 KB  |  102 lines
  1. 100   ' biorythm program for ATARI 520ST - by James H. Trageser
  2. 200   ' "Newtitle" downloaded from Compuserve ATARI16 SIG
  3. 300   ' On Color systems use Medium resolution
  4. 1000  gosub newtitle:' Change title of Output window
  5. 1010  Dim A$(10):x0=1:xfs=500:y0=50:yfs=100:ymax=1
  6. 1020  clrline$="                                                               "
  7. 1030  poke systab+24,1:fullw 2:clearw 2:color 1,1,1,1:poke systab+24,0
  8. 1040  gotoxy 1,10:Print "ENTER BIRTH DATE MM,DD,YYYY ";
  9. 1050  Input M,D,Yr
  10. 1060  Gosub 1390
  11. 1070  Tbd=D3
  12. 1080  Bm=M:Bd=D:By=Yr
  13. 1090  gosub blankline
  14. 1100  gotoxy 1,10:Print "ENTER DATE YOU WANT TO SEE PLOT FOR--";
  15. 1110  Input M,D,Yr
  16. 1120  Gosub 1390
  17. 1130  Cm=M:Cd=D:Cy=Yr
  18. 1140  Days=D3-Tbd
  19. 1150  Gosub plotsine
  20. 1160  P=Days/23
  21. 1170  P=P-Int(Days/23)
  22. 1180  P=P*23
  23. 1190  Pp=P*(xfs/23)
  24. 1200  I=(Days/33)-Int(Days/33)
  25. 1210  I=I*33
  26. 1220  Ip=I*(xfs/33)
  27. 1230  E=(Days/28)-Int(Days/28)
  28. 1240  E=E*28
  29. 1250  Ep=E*(xfs/28)
  30. 1260  Gosub plotline
  31. 1270  gotoxy 1,6:? clrline$
  32. 1280  gotoxy 1,6
  33. 1290  Print "Birthdate: ";Bm;"/";Bd;"/";By;"      Plot for: ";Cm;"/";Cd;"/";Cy
  34. 1300  gosub blankline
  35. 1310  gotoxy 1,10:Print "DO YOU WANT ANOTHER DAY ";
  36. 1320  Input A$
  37. 1330  gosub blankline
  38. 1340  If A$="Y" OR A$="y" Then 1700
  39. 1350  If A$="N" OR A$="n" Then 1790
  40. 1360  Goto 1310
  41. 1370  blankline:gotoxy 1,10:? clrline$
  42. 1380  return
  43. 1390  If Yr<100 Then Yr=Yr+1900:' Convert m/d/y to days
  44. 1400  If M<2 Then 1430
  45. 1410  D1=Int(365.25*Yr)
  46. 1420  D2=Int((M+1)*30.6):Goto 1450
  47. 1430  D1=Int(365.25*(Yr-1))
  48. 1440  D2=Int((M+13)*30.6)
  49. 1450  D3=D+D1+D2
  50. 1460  Return 
  51. 1470  plotsine:' Plot sinewave on screen
  52. 1480  LINEF x0,y0,xfs,y0
  53. 1490  xold=x0:yold=y0
  54. 1500  For X=.050 to 3.1416*2 step .050
  55. 1510  y=(yfs/2)*sin(x):yp=y0+1-y:xp=x*((xfs+1)/6.2832)
  56. 1520  LINEF xold,yold,xp,yp:xold=xp:yold=yp
  57. 1530  Next X
  58. 1540  reset
  59. 1550  Return 
  60. 1560  plotline:LINEF Pp,ymax,Pp,yfs:' Put E, I, and P lines on sinewave
  61. 1570  LINEF Ip,ymax,Ip,yfs
  62. 1580  LINEF Ep,ymax,Ep,yfs
  63. 1590  linef Pp+3,ymax+5,Pp+3,ymax+15
  64. 1600  linef Pp+4,ymax+5,pp+7,ymax+5
  65. 1610  linef Pp+8,ymax+6,Pp+8,ymax+6:linef Pp+9,ymax+7,pp+9,ymax+9
  66. 1620  linef Pp+8,ymax+10,Pp+8,ymax+10:linef Pp+7,ymax+11,Pp+3,ymax+11
  67. 1630  linef Ip+5,ymax+20,Ip+5,ymax+30
  68. 1640  linef Ip+3,ymax+20,Ip+7,ymax+20
  69. 1650  linef Ip+3,ymax+30,Ip+7,ymax+30
  70. 1660  linef Ep+3,ymax+35,Ep+3,ymax+45
  71. 1670  linef Ep+3,ymax+45,Ep+8,ymax+45:linef Ep+3,ymax+40,Ep+7,ymax+40
  72. 1680  linef Ep+3,ymax+35,Ep+8,ymax+35
  73. 1690  Return 
  74. 1700  clearw 2
  75. 1710  openw 2
  76. 1720  gosub blankline
  77. 1730  gotoxy 1,10:Print "ENTER NEW DATE: ";
  78. 1740  Input M,D,Yr
  79. 1750  Gosub 1390
  80. 1760  Cm=M:Cd=D:Cy=Yr
  81. 1770  Days=D3-Tbd
  82. 1780  Goto 1160
  83. 1790  gosub blankline
  84. 1800  gotoxy 1,10:Print "DO YOU WANT TO START A NEW PLOT ";:Input A$
  85. 1810  If A$="Y" or A$="y" then 1840
  86. 1820  If A$="N" or A$="n" Then 1850
  87. 1830  Goto 1790
  88. 1840  Goto 1030
  89. 1850  stop
  90. 32000 newtitle: ' New title for OUTPUT window
  91. 32001 poke systab+24,1 : ' Don't need to see this...
  92. 32002 a# = gb : ' Fetch globals address
  93. 32003 gintin = peek(a#+8) : ' AES int_in array
  94. 32004 poke gintin+0,peek(systab+8) : ' OUTPUT window handle
  95. 32005 poke gintin+2,2 : ' we're changing it's name
  96. 32006 s# = gintin+4 : ' DBL address for long poke
  97. 32007 title$ = "Biorythym" + chr$(0) : ' assure zero terminator
  98. 32008 poke s#,varptr(title$) : ' title of new window
  99. 32009 gemsys(105) : ' wind_set AES call
  100. 32010 poke systab+24,0 : ' Turn things back on
  101. 32011 return
  102. əəəəəəəəəəəəəəəəəəəəəəəəəəəəəəəəəəəəəəəəəəəəəəəəəəəəəəəəəəəəəəəəəəəəəəəəəəəəəəəəəəəəəəəəəəəəəəəəə